home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / HUNCHY.ZIP / GREDIT3.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1980-01-01  |  9.8 KB  |  331 lines
  1. program Graphics_Editor;
  2.  
  3. (*
  4.         GRAPHICS EDITOR FOR GETPIC & PUTPIC IN TURBO PASCAL 4.0
  5.          made especially for the graphics used by Hunch Back.
  6.         -----------------------------------------------------------
  7.  
  8.         Up, Down, Left, Right, Home, End, PgUp, PgDn :
  9.                               Cursor keys control the box cursor.
  10.         F1 - F4 :             Choose color (Black,Cyan,Magenta,White).
  11.         F5 :                  Draw/Not draw in current color
  12.         F6 :                  Flip image horizontally
  13.         F7 :                  Flip image vertically
  14.         F8 :                  Clear image
  15.         F9 :                  Load image
  16.         F10 :                 Save image
  17.         INS :                 Center image
  18.         ESC :                 Quit (Answer Y or N)
  19. *)
  20.  
  21. uses Crt, Graph3, Graph, CGAdrv;
  22.  
  23. type
  24.   St40 = string [40];
  25.  
  26. var
  27.   X,Y,Col,XCtr,YCtr,Tmp,Ex,Ey,Ex1,Ey1 : byte;
  28.   Crsr : array [1..10] of byte;
  29.   Icon : array [1..1675] of byte;
  30.   IconData : array [1..104,1..64] of byte;
  31.   Temp : array [1..3000] of byte;
  32.   Gd,Gm,Size,Ctr: integer;
  33.   Key : char;
  34.   Draw,Found:boolean;
  35.   FilName,OldF:st40;
  36.   Siz:string[10];
  37.   FilVar: file of byte;
  38.  
  39. function Exist (FilName:St40):boolean;
  40. var fil:file; e:boolean;
  41. begin
  42.   Assign (Fil,FilName); {$I-}
  43.   Reset (Fil);          {$I+}
  44.   E:=(IOResult=0);
  45.   if E then Close (Fil);
  46.   Exist:=E;
  47. end;
  48.  
  49. function ImSize(x1,y1,x2,y2:word):word;
  50. var
  51.   x,y:word;
  52. begin
  53.   x:=x2-x1+1; Y:=y2-y1+1;
  54.   ImSize:=(6+Trunc((x*2+7)/8)*y);
  55. end;
  56.  
  57. procedure Cursor (X,Y:byte);
  58. var X3,Y3:word;
  59. begin
  60.   X3:=X*3; Y3:=Y*3;
  61.   SetColor(GetPixel(X3,Y3) xor 3);
  62.   Rectangle(X3-2,Y3-2,X3,Y3);
  63. end;
  64.  
  65. procedure Frame (Col:byte);
  66. begin
  67.   SetColor (Col);
  68.   Rectangle (0,0,313,193);
  69. end;
  70.  
  71. procedure Dot (X,Y,Col:byte);
  72. var
  73.   X3,Y3:integer;
  74. begin
  75.   X3:=X*3; Y3:=Y*3;
  76.   SetColor(Col);
  77.   Rectangle(X3-2,Y3-2,X3,Y3);
  78.   PutPixel (X3-1,Y3-1,Col);
  79. end;
  80.  
  81. procedure MakeWindow (x,y,x1,y1:integer);
  82. begin
  83.   GetImage (x,y,x1,y1,Temp);
  84.   SetViewPort (x,y,x1,y1,ClipOn);
  85.   ClearViewPort;
  86.   SetColor (2);
  87.   Rectangle (0,0,x1-x,y1-y);
  88. end;
  89.  
  90. procedure CloseWindow;
  91. begin
  92.   PutImage (0,0,Temp,NormalPut);
  93.   SetViewPort (0,0,319,199,ClipOn);
  94. end;
  95.  
  96. function Yes (Ask : St40):boolean;
  97. var
  98.   Key:char;
  99. begin
  100.   MakeWindow (104,78,216,102);
  101.   SetColor (3);
  102.   OutTextXY (56-(Length(Ask)*4),8,Ask);
  103.   Key:=ReadKey;
  104.   CloseWindow;
  105.   Yes:=(Key in ['Y','y']);
  106. end;
  107.  
  108. procedure Clear;
  109. begin
  110.   SetViewPort (1,1,312,192,True);
  111.   ClearViewPort;
  112.   SetViewPort (0,0,319,199,True);
  113.   for YCtr:=1 to 64 do
  114.   for XCtr:=1 to 104 do
  115.   IconData[XCtr,YCtr]:=0;
  116. end;
  117.  
  118. procedure FindImage;
  119. var
  120.   x,y:byte;
  121.   c:boolean;
  122.  
  123.   procedure Fr(C:byte);
  124.   begin
  125.     SetColor(C);
  126.     Rectangle (Ex-1,Ey-1,Ex1+1,Ey1+1);
  127.   end;
  128. begin
  129.   Found:=True;
  130.   Ex:=8; Ex1:=113; Ey:=8; Ey1:=73;
  131.   repeat
  132.     Inc(Ex);
  133.     y:=8; repeat Inc(y); c:=(GetPixel(Ex,y)>0);
  134.     until c or (y=73);
  135.   until c or (Ex=113);
  136.   if not c then begin
  137.     SetColor (3);
  138.     OutTextXY(24,36,'No Image!');
  139.     Found:=False;
  140.   end else begin
  141.     repeat
  142.       Dec(Ey1);
  143.       x:=Ex-1; repeat Inc(x); c:=(GetPixel(x,Ey1)>0);
  144.       until c or (x=Ex1);
  145.     until c or (Ey1=8);
  146.     repeat
  147.       Dec(Ex1);
  148.       y:=8; repeat Inc(y); c:=(GetPixel(Ex1,y)>0);
  149.       until c or (y=Ey1);
  150.     until c or (Ex1=8);
  151.     repeat
  152.       Inc(Ey);
  153.       x:=Ex-1; repeat Inc(x); c:=(GetPixel(x,Ey)>0);
  154.       until c or (x=Ex1);
  155.     until c or (Ey=Ey1);
  156.     GetPic (Icon,100+Ex,50+Ey,100+Ex1,50+Ey1);
  157. (*    SetColor (1); SetLineStyle (DottedLn,0,1);
  158.     Fr(3);
  159.     SetLineStyle (SolidLn,0,1);*)
  160.     Size:=ImSize (Ex,Ey,Ex1,Ey1);
  161.     Str(Size,Siz);
  162.     SetColor (3);
  163.     OutTextXY (20,78,'Size: '+Siz);
  164.   end;
  165. end;
  166.  
  167. procedure MakeIconData(x,y:byte);
  168. begin
  169.   MakeWindow (100,50,220,138);
  170.   PutPic (Icon,108+x,122-y);
  171.   for XCtr:=1 to 104 do
  172.     for YCtr:=1 to 64 do
  173.       IconData[XCtr,YCtr]:=GetPixel (8+XCtr,8+YCtr);
  174.   CloseWindow;
  175.   for XCtr:=1 to 104 do
  176.     for YCtr:=1 to 64 do
  177.       if IconData[XCtr,YCtr]>0 then Dot(XCtr,YCtr,IconData[XCtr,YCtr]);
  178. end;
  179.  
  180. procedure ShowImage;
  181. var Key:char;
  182. begin
  183.   MakeWindow (100,50,220,138);
  184.   for XCtr:=1 to 104 do
  185.     for YCtr:=1 to 64 do
  186.       PutPixel (8+XCtr,8+YCtr,IconData [XCtr,YCtr]);
  187.   FindImage;
  188.   Key:=ReadKey;
  189.   CloseWindow;
  190. end;
  191.  
  192. function GetFileName (OldF:St40; Txt:St40):St40;
  193. var
  194.   FilName:St40;
  195. begin
  196.   MakeWindow(104,72,216,107);
  197.   SetColor (3); OutTextXY (8,7,Txt+' file:');
  198.   Window (15,12,26,13); OutTextXY(8,16,OldF);
  199.   repeat until KeyPressed;
  200.   repeat ClrScr; GotoXY(1,1); Readln (FilName);
  201.   until ((FilName='') and (OldF>'')) or (FilName>'');
  202.   Window (1,1,40,25); CloseWindow;
  203.   if FilName>'' then GetFileName:=FilName
  204.     else GetFileName:=OldF;
  205. end;
  206.  
  207. begin
  208.   RegisterCGA;
  209.   InitCGA (CGAC3);
  210.   GraphColorMode;
  211.   FillChar(IconData,SizeOf(IconData),0);
  212.   FilName:='';
  213.   X:=52; Y:=32; Draw:=False; Col:=3;
  214.   Frame (Col);
  215.   Cursor (X,Y);
  216.   repeat
  217.     Key:=ReadKey;
  218.     Cursor (X,Y);
  219.     if Draw then begin
  220.       IconData [X,Y]:=Col;
  221.       Dot (X,Y,Col);
  222.     end;
  223.     case Key of
  224.       #0 : begin
  225.              if KeyPressed then begin
  226.                Key:=ReadKey;
  227.                case Key of
  228.                  'G': begin Dec (Y); Dec (X); end;
  229.                  'H': Dec (Y);
  230.                  'I': begin Dec (Y); Inc (X); end;
  231.                  'K': Dec (X);
  232.                  'M': Inc (X);
  233.                  'O': begin Inc (Y); Dec (X); end;
  234.                  'P': Inc (Y);
  235.                  'Q': begin Inc (Y); Inc (X); end;
  236.                  #59..#62: begin
  237.                              Col:=Ord(Key)-59;
  238.                              Dot (X,Y,Col);
  239.                              IconData [X,Y]:=Col;
  240.                              Frame (Col);
  241.                            end;
  242.                  #63: Draw:=not Draw;
  243.                  #64: begin
  244.                         for YCtr:=1 to 32 do
  245.                           for XCtr:= 1 to 104 do
  246.                             if IconData[XCtr,YCtr]<>IconData[XCtr,65-YCtr] then begin
  247.                               Tmp:=IconData [XCtr,YCtr];
  248.                               IconData[XCtr,YCtr]:=IconData[XCtr,65-YCtr];
  249.                               IconData[XCtr,65-YCtr]:=Tmp;
  250.                               Dot (XCtr,YCtr,IconData [XCtr,YCtr]);
  251.                               Dot (XCtr,65-YCtr,Tmp);
  252.                             end;
  253.                         Y:=65-Y;
  254.                       end;
  255.                  #65: begin
  256.                         for XCtr:=1 to 52 do
  257.                           for YCtr:= 1 to 64 do
  258.                             if IconData[XCtr,YCtr]<>IconData[105-XCtr,YCtr] then begin
  259.                               Tmp:=IconData [XCtr,YCtr];
  260.                               IconData[XCtr,YCtr]:=IconData[105-XCtr,YCtr];
  261.                               IconData[105-XCtr,YCtr]:=Tmp;
  262.                               Dot (XCtr,YCtr,IconData [XCtr,YCtr]);
  263.                               Dot (105-XCtr,YCtr,Tmp);
  264.                             end;
  265.                         X:=105-X;
  266.                       end;
  267.                  #66: if Yes ('Clear Image?') then Clear;
  268.                  #67: begin
  269.                         if Yes('Load Image?') then begin
  270.                           FilName:=GetFileName(FilName,'Load');
  271.                           if Exist(FilName) then begin
  272.                             Assign (FilVar,FilName);
  273.                             Reset (FilVar);
  274.                             for Ctr:=1 to 6 do
  275.                               Read (FilVar,Icon[Ctr]);
  276.                             Size:=ImSize(1,1,Icon[4]*256+Icon[3],
  277.                                              Icon[6]*256+Icon[5]);
  278.                             for Ctr:=7 to Size do
  279.                               Read (FilVar,Icon[Ctr]);
  280.                             Close (FilVar);
  281.                             Clear;
  282.                             MakeIconData(52-(Icon[4]*256+Icon[3]) div 2,
  283.                                          31-(Icon[6]*256+Icon[5]) div 2);
  284. (*                            CloseGraph;
  285.                             for Ctr:=1 to Size do Write(Icon[Ctr]:4);
  286.                             Key:=ReadKey;
  287.                             InitCGA(CGAC1);*)
  288.                           end else Write (Chr(7));
  289.                         end;
  290.                       end;
  291.                  #68: begin
  292.                         ShowImage;
  293.                         if Found then if Yes('Save Image?') then begin
  294.                           Size:=ImSize(Ex,Ey,Ex1,Ey1);
  295. (*                          CloseGraph;
  296.                           for Ctr:=1 to Size do Write(Icon[Ctr]:4);
  297.                           Key:=ReadKey;
  298.                           InitCGA(CGAC1);*)
  299.                           FilName:=GetFileName(FilName,'Save');
  300.                           Found:=Exist(FilName);
  301.                           if Found then Found:=not Yes('Overwrite?');
  302.                           if not Found then begin
  303.                             Assign (FilVar,FilName);
  304.                             ReWrite (FilVar);
  305.                             for Ctr:=1 to Size do
  306.                               Write (FilVar,Icon[Ctr]);
  307.                             Close (FilVar);
  308.                           end;
  309.                         end;
  310.                       end;
  311.                  #82: begin
  312.                         ShowImage;
  313.                         if Found then if Yes ('Center Img.?') then begin
  314.                           Clear;
  315.                           MakeIconData(52-(Ex1-Ex) div 2,31-(Ey1-Ey) div 2);
  316.                         end;
  317.                       end;
  318.                end;
  319.                if X>104 then X:=1;
  320.                if X<1 then X:=104;
  321.                if Y<1 then Y:=64;
  322.                if Y>64 then Y:=1;
  323.              end;
  324.            end;
  325.     end;
  326.     Cursor (X,Y);
  327.     if Key=#27 then
  328.       if Yes ('Quit GREDIT?')=False then Key:=#0;
  329.   until Key=#27;
  330.   TextMode (CO80);
  331. end.